home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / reflect.scm < prev    next >
Encoding:
Text File  |  1991-06-21  |  2.3 KB  |  88 lines
  1.  
  2. ; Scheme translator environment and module
  3.  
  4. (define scheme-translator-env
  5.   (make-program-env
  6.      'scheme-translator
  7.      (list revised^4-scheme-module)))
  8.  
  9. (define scheme-translator-sig
  10.   (make-signature
  11.     'scheme-translator
  12.     '(make-program-env
  13.       make-signature
  14.       make-module
  15.       program-env-id
  16.       program-env-package
  17.       program-env-lookup
  18.       program-env-define!
  19.       translate
  20.       translate-lambda
  21.       really-translate-file
  22.       translator-version
  23.       perform-usual-integrations!
  24.       scheme-translator-env
  25.       scheme-translator-module
  26.       revised^4-scheme-module
  27.       scheme-user-environment
  28.       )
  29.     '()))
  30.  
  31. (define scheme-translator-module
  32.   (make-module 'scheme-translator
  33.            scheme-translator-sig
  34.            scheme-translator-env))
  35.  
  36. (define (move-value-or-denotation name from to)
  37.   (let ((den (program-env-lookup from name)))
  38.     (if (and (node? den)
  39.          (program-variable? den))
  40.     (let ((from-sym (program-variable-cl-symbol den)))
  41.       (lisp:if (lisp:boundp from-sym)
  42.            (let ((to-sym (program-variable-cl-symbol
  43.                   (program-env-lookup to name))))
  44.              (lisp:setf (lisp:symbol-value to-sym)
  45.                 (lisp:symbol-value from-sym))
  46.              (schi:set-function-from-value to-sym))
  47.            ;; This case handles ELSE and =>.
  48.            (program-env-define! to name den)))
  49.     (program-env-define! to name den))))
  50.  
  51.  
  52. ; A pristine user environment with no integrations.
  53.  
  54. (define scheme-user-environment
  55.   (make-program-env 'scheme '()))
  56.  
  57. (for-each (lambda (name)
  58.         (move-value-or-denotation name
  59.                       revised^4-scheme-env
  60.                       scheme-user-environment))
  61.       (signature-names revised^4-scheme-sig))
  62.  
  63.  
  64. ; Add integrations ("benchmark mode")
  65.  
  66. (define (perform-usual-integrations! env)
  67.   (for-each (lambda (name)
  68.           (let ((probe (get-integration
  69.                  (program-env-lookup revised^4-scheme-env name))))
  70.         (if probe
  71.             (define-integration! (program-env-lookup env name)
  72.               probe))))
  73.         (signature-names revised^4-scheme-sig)))
  74.  
  75.  
  76. ; These don't really belong anywhere
  77.  
  78. (define (eval-for-syntax form env)
  79.   (lisp:eval (translate form env)))
  80.  
  81. (let ((env (get-environment-for-syntax scheme-user-environment)))
  82.   (eval-for-syntax `(define syntax-error #f) env)
  83.   ((eval-for-syntax `(lambda (x) (set! syntax-error x)) env)
  84.    syntax-error))
  85.  
  86. (define (error . rest)
  87.   (apply #'schi:scheme-error rest))
  88.